home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / bcomp / package.scm < prev    next >
Text File  |  1995-10-13  |  13KB  |  426 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Structures 'n' packages.
  5.  
  6. ; --------------------
  7. ; Structures
  8.  
  9. (define-record-type structure :structure
  10.   (really-make-structure package interface-thunk interface clients name)
  11.   structure?
  12.   (interface-thunk structure-interface-thunk)
  13.   (interface structure-interface-really set-structure-interface!)
  14.   (package   structure-package)    ; allow #f
  15.   (clients   structure-clients)
  16.   (name         structure-name set-structure-name!))
  17.  
  18. (define-record-discloser :structure
  19.   (lambda (s) (list 'structure
  20.             (package-uid (structure-package s))
  21.             (structure-name s))))
  22.  
  23. (define (structure-interface s)
  24.   (or (structure-interface-really s)
  25.       (begin (initialize-structure! s)
  26.          (structure-interface-really s))))
  27.  
  28. (define (initialize-structure! s)
  29.   (let ((int ((structure-interface-thunk s))))
  30.     (if (interface? int)
  31.     (begin (set-structure-interface! s int)
  32.            (note-reference-to-interface! int s))
  33.     (call-error "invalid interface" initialize-structure! s))))
  34.  
  35. (define (make-structure package int-thunk . name-option)
  36.   (if (not (package? package))
  37.       (call-error "invalid package" make-structure package int-thunk))
  38.   (let ((struct (really-make-structure package
  39.                        (if (procedure? int-thunk)
  40.                        int-thunk
  41.                        (lambda () int-thunk))
  42.                        #f
  43.                        (make-population)
  44.                        #f)))
  45.     (if (not (null? name-option))
  46.     (note-structure-name! struct (car name-option)))
  47.     (add-to-population! struct (package-clients package))
  48.     struct))
  49.  
  50. (define (structure-unstable? struct)
  51.   (package-unstable? (structure-package struct)))
  52.  
  53. (define (for-each-export proc struct)
  54.   (let ((int (structure-interface struct)))
  55.     (for-each-declaration
  56.         (lambda (name want-type)
  57.       (let ((binding (structure-lookup struct name #t)))
  58.         (proc name
  59.           (if (and (binding? binding)
  60.                (eq? want-type undeclared-type))
  61.               (let ((type (binding-type binding)))
  62.             (if (variable-type? type)
  63.                 (variable-value-type type)
  64.                 type))
  65.               want-type)
  66.           binding)))
  67.     int)))
  68.  
  69. (define (note-structure-name! struct name)
  70.   (if (and name (not (structure-name struct)))
  71.       (begin (set-structure-name! struct name)
  72.          (note-package-name! (structure-package struct) name))))
  73.  
  74. ; --------------------
  75. ; Packages
  76.  
  77. (define-record-type package :package
  78.   (really-make-package uid
  79.                opens-thunk opens accesses-thunk
  80.                definitions
  81.                get-location
  82.                plist
  83.                cached
  84.                clients
  85.                unstable?
  86.                file-name clauses loaded?)
  87.   package?
  88.   (uid               package-uid)
  89.   (opens           package-opens-really set-package-opens!)
  90.   (definitions     package-definitions)
  91.   (unstable?       package-unstable?)
  92.   (integrate?      package-integrate? set-package-integrate?!)
  93.  
  94.   ;; For EVAL and LOAD (which can only be done in unstable packages)
  95.   (get-location    package-get-location set-package-get-location!)
  96.   (file-name       package-file-name)
  97.   (clauses         package-clauses)
  98.   (loaded?         package-loaded? set-package-loaded?!)
  99.   (env             package->environment set-package->environment!)
  100.  
  101.   ;; For package mutation
  102.   (opens-thunk     package-opens-thunk set-package-opens-thunk!)
  103.   (accesses-thunk  package-accesses-thunk)
  104.   (plist           package-plist set-package-plist!)
  105.   (clients         package-clients)
  106.   (cached       package-cached))
  107.  
  108. (define-record-discloser :package
  109.   (lambda (p)
  110.     (let ((name (package-name p)))
  111.       (if name
  112.       (list 'package (package-uid p) name)
  113.       (list 'package (package-uid p))))))
  114.  
  115. (define (make-package opens-thunk accesses-thunk unstable? tower file clauses
  116.               uid name)
  117.   (let ((p (really-make-package
  118.         (if uid
  119.         (begin (if (>= uid *package-uid*)
  120.                (set! *package-uid* (+ uid 1)))
  121.                uid)
  122.         (new-package-uid))
  123.         opens-thunk
  124.         #f                ;opens
  125.         accesses-thunk        ;thunk returning alist
  126.         (make-table name-hash)    ;definitions
  127.         (fluid $get-location)    ;procedure for making new locations
  128.         '()                ;property list...
  129.         (make-table name-hash)    ;bindings cached in templates
  130.         (make-population)        ;structures
  131.         unstable?            ;unstable (suitable for EVAL)?
  132.         file            ;file containing DEFINE-STRUCTURE form
  133.         clauses            ;misc. DEFINE-STRUCTURE clauses
  134.         #f)))            ;loaded?
  135.     (note-package-name! p name)
  136.     (set-package->environment! p (really-package->environment p))
  137.     (if unstable?            ;+++
  138.     (define-funny-names! p tower))
  139.     p))
  140.  
  141. (define (really-package->environment p)
  142.   (lambda (name)
  143.     (package-lookup p name)))
  144.  
  145. ; Unique id's
  146.  
  147. (define (new-package-uid)
  148.   (let ((uid *package-uid*))        ;unique identifier
  149.     (set! *package-uid* (+ *package-uid* 1))
  150.     uid))
  151.  
  152. (define *package-uid* 0)
  153.  
  154. ; Package names
  155.  
  156. (define package-name-table (make-table))
  157.  
  158. (define (package-name package)
  159.   (table-ref package-name-table (package-uid package)))
  160.  
  161. (define (note-package-name! package name)
  162.   (if name
  163.       (let ((uid (package-uid package)))
  164.     (if (not (table-ref package-name-table uid))
  165.         (table-set! package-name-table uid name)))))
  166.  
  167. (define (package-opens p)
  168.   (initialize-package-if-necessary! p)
  169.   (package-opens-really p))
  170.  
  171. (define (initialize-package-if-necessary! p)
  172.   (if (not (package-opens-really p))
  173.       (initialize-package! p)))
  174.  
  175. (define (package-accesses p)        ;=> alist
  176.   ((package-accesses-thunk p)))
  177.  
  178. ; --------------------
  179. ; A simple package has no ACCESSes or other far-out clauses.
  180.  
  181. (define (make-simple-package opens unstable? tower . name-option)
  182.   (if (not (list? opens))
  183.       (error "invalid package opens list" opens))
  184.   (let ((p (make-package (lambda () opens)
  185.              (lambda () '()) ;accesses-thunk
  186.              unstable?
  187.              tower
  188.              ""        ;file containing DEFINE-STRUCTURE form
  189.              '()        ;clauses
  190.              #f        ;uid
  191.              (if (null? name-option)
  192.                  #f
  193.                  (car name-option)))))
  194.     (set-package-loaded?! p #t)
  195.     p))
  196.  
  197. ; --------------------
  198. ; The definitions table
  199.  
  200. ; Each entry in the package-definitions table is a binding
  201. ; #(type place static).  "Place" will typically be a location,
  202. ; but it doesn't have to be.
  203.  
  204. (define (package-definition p name)
  205.   (initialize-package-if-necessary! p)
  206.   (let ((probe (table-ref (package-definitions p) name)))
  207.     (if probe
  208.     (maybe-fix-place probe)
  209.     #f)))
  210.  
  211. ; Disgusting.  Interface predates invention of "binding" records.
  212.  
  213. (define (package-define! p name type-or-static . place-option)
  214.   (let ((place (if (null? place-option)
  215.            #f
  216.            (car place-option))))
  217.     (cond ((transform? type-or-static)
  218.        (really-package-define! p name
  219.                    (transform-type type-or-static)
  220.                    place
  221.                    type-or-static))
  222.       ((operator? type-or-static)
  223.        (really-package-define! p name
  224.                    (operator-type type-or-static)
  225.                    place
  226.                    type-or-static))
  227.       (else
  228.        (really-package-define! p name
  229.                    type-or-static
  230.                    place
  231.                    #f)))))
  232.     
  233.  
  234. (define (really-package-define! p name type place static)
  235.   (let ((probe (table-ref (package-definitions p) name)))
  236.     (if probe
  237.     (begin (clobber-binding! probe type place static)
  238.            (binding-place (maybe-fix-place probe)))
  239.     (let ((place (or place (get-new-location p name))))
  240.       (table-set! (package-definitions p)
  241.               name
  242.               (make-binding type place static))
  243.       place))))
  244.  
  245.  
  246. ; --------------------
  247. ; Lookup
  248.  
  249. ; Look up a name in a package.  Returns a binding if bound, or a name if
  250. ; not.  In the unbound case, the name returned is either the original
  251. ; name or, if the name is generated, the name's underlying symbol.
  252.  
  253. (define (package-lookup p name)
  254.   (really-package-lookup p name (package-integrate? p)))
  255.  
  256. (define (really-package-lookup p name integrate?)
  257.   (let ((probe (package-definition p name)))
  258.     (cond (probe
  259.        (if integrate?
  260.            probe
  261.            (forget-integration probe)))
  262.       ((generated? name)
  263.        (generic-lookup (generated-env name)
  264.                (generated-symbol name)))
  265.       (else
  266.        (let loop ((opens (package-opens-really p)))
  267.          (if (null? opens)
  268.          name            ;Unbound
  269.          (or (structure-lookup (car opens) name integrate?)
  270.              (loop (cdr opens)))))))))
  271.  
  272. ; Get a name's binding in a structure.  If the structure doesn't
  273. ; export the name, this returns #f.  If the structure exports the name
  274. ; but the name isn't bound, it returns the name.
  275.  
  276. (define (structure-lookup struct name integrate?)
  277.   (let ((type (interface-ref (structure-interface struct) name)))
  278.     (if type
  279.     (impose-type type
  280.              (really-package-lookup (structure-package struct)
  281.                         name
  282.                         integrate?)
  283.              integrate?)
  284.     #f)))
  285.  
  286. (define (generic-lookup env name)
  287.   (cond ((package? env)
  288.      (package-lookup env name))
  289.     ((structure? env)
  290.      (or (structure-lookup env name
  291.                    (package-integrate? (structure-package env)))
  292.          (call-error "not exported" generic-lookup env name)))
  293.     ((procedure? env)
  294.      (lookup env name))
  295.     (else
  296.      (error "invalid environment" env name))))
  297.  
  298. ; --------------------
  299. ; Package initialization
  300.  
  301. (define (initialize-package! p)
  302.   (let ((opens ((package-opens-thunk p))))
  303.     (set-package-opens! p opens)
  304.     (for-each (lambda (struct)
  305.         (if (structure-unstable? struct)
  306.             (add-to-population! p (structure-clients struct))))
  307.           opens))
  308.   (for-each (lambda (name+struct)
  309.           ;; Cf. CLASSIFY method for STRUCTURE-REF
  310.           (really-package-define! p
  311.                       (car name+struct)
  312.                       structure-type
  313.                       #f
  314.                       (cdr name+struct)))
  315.         (package-accesses p)))
  316.  
  317.  
  318. (define (define-funny-names! p tower)
  319.   (package-define-funny! p funny-name/the-package p)
  320.   (if tower
  321.       (package-define-funny! p funny-name/reflective-tower
  322.                  tower)))
  323.  
  324. (define (package-define-funny! p name static)
  325.   (table-set! (package-definitions p)
  326.           name
  327.           (make-binding syntax-type (cons 'dummy-place name) static)))
  328.  
  329.  
  330. ; The following funny name is bound in every package to the package
  331. ; itself.  This is a special hack used by the byte-code compiler
  332. ; (procedures LOCATION-FOR-UNDEFINED and NOTE-CACHING) so that it can
  333. ; extract the underlying package from any environment.
  334.  
  335. (define funny-name/the-package (string->symbol ".the-package."))
  336.  
  337. (define (extract-package-from-environment env)
  338.   (get-funny env funny-name/the-package))
  339.  
  340. ; (define (package->environment? env)
  341. ;   (eq? env (package->environment
  342. ;            (extract-package-from-environment env))))
  343.  
  344.  
  345. ; --------------------
  346. ; For implementation of INTEGRATE-ALL-PRIMITIVES! in scanner, etc.
  347.  
  348. (define (for-each-definition proc p)
  349.   (table-walk (lambda (name binding)
  350.         (proc name (maybe-fix-place binding)))
  351.           (package-definitions p)))
  352.  
  353. ; --------------------
  354. ; Locations
  355.  
  356. (define (get-new-location p name)
  357.   ((package-get-location p) p name))
  358.  
  359. ; Default new-location method for new packages
  360.  
  361. (define (make-new-location p name)
  362.   (let ((uid *location-uid*))
  363.     (set! *location-uid* (+ *location-uid* 1))
  364.     (table-set! location-info-table uid
  365.         (make-immutable!
  366.          (cons (name->symbol name) (package-uid p))))
  367.     (make-undefined-location uid)))
  368.  
  369. (define $get-location (make-fluid make-new-location))
  370.  
  371. (define *location-uid* 5000)  ; 1510 in initial system as of 1/22/94
  372.  
  373. (define location-info-table (make-table))
  374.  
  375.  
  376. (define (flush-location-names)
  377.   (set! location-info-table (make-table))
  378.   ;; (set! package-name-table (make-table)) ;hmm, not much of a space saver
  379.   )
  380.  
  381. ; --------------------
  382. ; Extra
  383.  
  384. (define (package-get p ind)
  385.   (cond ((assq ind (package-plist p)) => cdr)
  386.     (else #f)))
  387.  
  388. (define (package-put! p ind val)
  389.   (cond ((assq ind (package-plist p)) => (lambda (z) (set-cdr! z val)))
  390.     (else (set-package-plist! p (cons (cons ind val)
  391.                       (package-plist p))))))
  392.  
  393. ; compiler calls this
  394.  
  395. (define (package-note-caching p name place)
  396.   (if (package-unstable? p)        ;?????
  397.       (if (not (table-ref (package-definitions p) name))
  398.       (let loop ((opens (package-opens p)))
  399.         (if (not (null? opens))
  400.         (if (interface-ref (structure-interface (car opens))
  401.                    name)
  402.             (begin (table-set! (package-cached p) name place)
  403.                (package-note-caching
  404.                    (structure-package (car opens))
  405.                    name place))
  406.             (loop (cdr opens)))))))
  407.   place)
  408.  
  409. ; Special kludge for shadowing and package mutation.
  410. ; Ignore this on first reading.  See env/shadow.scm.
  411.  
  412. (define (maybe-fix-place b)
  413.   (let ((place (binding-place b)))
  414.     (if (and (location? place)
  415.          (vector? (location-id place)))
  416.     (set-binding-place! b (follow-forwarding-pointers place))))
  417.   b)
  418.  
  419. (define (follow-forwarding-pointers place)
  420.   (let ((id (location-id place)))
  421.     (if (vector? id)
  422.     (follow-forwarding-pointers (vector-ref id 0))
  423.     place)))
  424.  
  425. ; (put 'package-define! 'scheme-indent-hook 2)
  426.